;------------------------------------------------------------
;------------------------------------------------------------
#lang racket
; Tony Hyun Kim
; 6.001 Project 5
; Dr. Koile / Jim
;------------------------------------------------------------
;------------------------------------------------------------
(require r5rs)

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define rest cdr)

(define (tagged-list? exp tag)
  (and (pair? exp) (eq? (car exp) tag)))

(define (self-evaluating? exp)
  (or (number? exp) (string? exp) (boolean? exp)))

(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))

(define (variable? exp) (symbol? exp))
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (make-assignment var expr)
  (list 'set! var expr))

(define (definition? exp) (tagged-list? exp 'define))
(define (definition-variable exp)
  (if (symbol? (cadr exp))   (cadr exp)   (caadr exp)))
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp) (cddr exp))))  ; formal params, body
(define (make-define var expr)
  (list 'define var expr))

(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters lambda-exp) (cadr lambda-exp))
(define (lambda-body lambda-exp) (cddr lambda-exp))
(define (make-lambda parms body) (cons 'lambda (cons parms body)))

(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp)) 
(define (if-consequent exp) (caddr exp)) 
(define (if-alternative exp) (cadddr exp))
(define (make-if pred conseq alt) (list 'if pred conseq alt))

(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define first-cond-clause car)
(define rest-cond-clauses cdr)
(define (make-cond seq) (cons 'cond seq))

(define (let? expr) (tagged-list? expr 'let))
(define (let-bound-variables expr) (map first (second expr)))
(define (let-values expr) (map second (second expr)))
(define (let-body expr) (cddr expr)) ;differs from lecture--body may be a sequence
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions begin-exp) (cdr begin-exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))
(define (make-begin exp) (cons 'begin exp))

(define (application? exp) (pair? exp))
(define (operator app) (car app))
(define (operands app) (cdr app))
(define (no-operands? args) (null? args))
(define (first-operand args) (car args))
(define (rest-operands args) (cdr args))
(define (make-application rator rands)
  (cons rator rands))

(define (and? expr) (tagged-list? expr 'and))
(define and-exprs cdr)
(define (make-and exprs) (cons 'and exprs))
(define (or? expr) (tagged-list? expr 'or))
(define or-exprs cdr)
(define (make-or exprs) (cons 'or exprs))

;;
;; this section is the actual implementation of meval 
;;


(define (m-eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))    
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        
        ;------------------------------------------------------------
        ; Problem 2/3/4/5: Catch the special forms here
        ;------------------------------------------------------------
        ((reset? exp)  (eval-reset exp env))
        ((before? exp) (eval-before exp env))
        ((around? exp) (eval-around exp env))
        ((after? exp)  (eval-around (after->around-let exp) env))
        
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp) (lambda-body exp) env))
        ((begin? exp) (eval-sequence (begin-actions exp) env))
        ((cond? exp) (m-eval (cond->if exp) env))
        ((let? exp) (m-eval (let->application exp) env))
        ((application? exp)
         (m-apply (m-eval (operator exp) env)
                  (list-of-values (operands exp) env)
                  env))
        (else (error "Unknown expression type -- EVAL" exp))))

;------------------------------------------------------------
; Problem 6: 
;   Note that m-apply now takes in as a third argument the 
;   calling environment. This is so because this information is
;   needed for checking constraints. Whether a procedure 
;   satisfies the constraint depends on the environment FROM
;   which it is called.
;------------------------------------------------------------
(define (m-apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        
        ;------------------------------------------------------------
        ; Problem 3/4: Apply the advice objects
        ;------------------------------------------------------------
        ((before-advice? procedure) (m-apply-before procedure arguments env))
        ((around-advice? procedure) (m-apply-around procedure arguments env))
        
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment (procedure-parameters procedure)
                              arguments
                              (procedure-environment procedure)
                              (procedure-name procedure))))
        (else (error "Unknown procedure type -- APPLY" procedure))))

(define (list-of-values exps env)
  (cond ((no-operands? exps) '())
        (else (cons (m-eval (first-operand exps) env)
                    (list-of-values (rest-operands exps) env)))))

(define (eval-if exp env)
  (if (m-eval (if-predicate exp) env)
      (m-eval (if-consequent exp) env)
      (m-eval (if-alternative exp) env)
      ))

(define (eval-sequence exps env)
  (cond ((last-exp? exps) (m-eval (first-exp exps) env))
        (else (m-eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (m-eval (assignment-value exp) env)
                       env))

(define (eval-definition exp env)
  (define-variable! (definition-variable exp)
                    (m-eval (definition-value exp) env)
                    env))

(define (let->application expr)
  (let ((names (let-bound-variables expr))
        (values (let-values expr))
        (body (let-body expr)))
    (make-application (make-lambda names body)
                      values)))

(define (cond->if expr)
  (let ((clauses (cond-clauses expr)))
    (if (null? clauses)
        #f
        (if (eq? (car (first-cond-clause clauses)) 'else)
            (make-begin (cdr (first-cond-clause clauses)))
            (make-if (car (first-cond-clause clauses))
                     (make-begin (cdr (first-cond-clause clauses)))
                     (make-cond (rest-cond-clauses clauses)))))))

(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (if (eq? input '**quit**)
        'meval-done
        (let ((output (m-eval input the-global-environment)))
          (announce-output output-prompt)
          (display output)
          (driver-loop)))))

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define *meval-warn-define* #t) ; print warnings?
(define *in-meval* #f)          ; evaluator running
;;
;; 
;; implementation of meval environment model
;;

;------------------------------------------------------------
; Problem 2: Changes to the 'binding' abstraction
;------------------------------------------------------------
(define (make-binding var val)
  (list var val val))
(define binding-variable car)
(define binding-value    cadr)
(define binding-original caddr)

(define (binding-search var frame)
  (if (null? frame)
      #f
      (if (eq? var (first (first frame)))
          (first frame)
          (binding-search var (rest frame)))))       

(define (set-binding-value! binding val)
  (set-car! (cdr binding) val))

(define (set-binding-original! binding val)
  (set-binding-value! (cdr binding) val))   ;; We simply take advantage of the
                                            ;; underlying structure.

(define (reset-binding-value! binding)
  (set-binding-value! binding
                      (binding-original binding)))

; frames 
;------------------------------------------------------------
; Problem 6: frames now record the symbol of the procedure
;            that created it.
;------------------------------------------------------------
(define (make-frame variables values creator)
  (list 'frame (map make-binding variables values) creator))
(define (frame-bindings  frame) (cadr frame))
(define (frame-creator   frame) (caddr frame))
(define (frame-variables frame) (map binding-variable (frame-bindings frame)))
(define (frame-values frame)    (map binding-value    (frame-bindings frame)))
(define (add-binding-to-frame! var val frame)
  (set-car! (cdr frame) (cons (make-binding var val) (frame-bindings frame))))
(define (find-in-frame var frame)
  (binding-search var (frame-bindings frame)))

; environments
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

(define (find-in-environment var env)
  (if (eq? env the-empty-environment)
      #f
      (let* ((frame (first-frame env))
             (binding (find-in-frame var frame)))
        (if binding
            binding
            (find-in-environment var (enclosing-environment env))))))

; drop a frame
;------------------------------------------------------------
; Problem 6: Necessary extension for recording the creator 
;            of each frame.
;------------------------------------------------------------
(define (extend-environment vars vals base-env creator)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals creator) base-env)
      (if (< (length vars) (length vals))
          (error "Too many args supplied" vars vals)
          (error "Too few args supplied" vars vals))))

; name rule
(define (lookup-variable-value var env)
  (let ((binding (find-in-environment var env)))
    (if binding
        (binding-value binding)
        (error "Unbound variable -- LOOKUP" var))))

(define (set-variable-value! var val env)
  (let ((binding (find-in-environment var env)))
    (if binding
        (set-binding-value! binding val)
        (error "Unbound variable -- SET" var))))

;; double bubbles
;------------------------------------------------------------
; Problem 6: Procedures can now hold onto the its symbolic name
;------------------------------------------------------------
(define (make-procedure parameters body env)
  (let ((default-name #f))
    (list 'procedure parameters body env default-name)))
(define (compound-procedure? proc)
  (tagged-list? proc 'procedure))
(define (procedure-parameters proc)  (second proc))
(define (procedure-body proc)        (third  proc))
(define (procedure-environment proc) (fourth proc))
(define (procedure-name proc)        (fifth  proc))
(define (procedure-set-name! proc new-name)
  (set-cdr! (cdddr proc) (list new-name)))

(define (define-variable! var val env)
  (let* ((frame (first-frame env))
         (binding (find-in-frame var frame)))
    (if binding
        ;------------------------------------------------------------
        ; Problem 2: Defining over existing variables
        ; Not only do we have to set the value, our desired effect is 
        ; that the second 'define' also sets the "default" value of
        ; the variable
        ;------------------------------------------------------------
        (begin
          (set-binding-value! binding val)
          (set-binding-original! binding val)
        )
        (add-binding-to-frame! var val frame)
    )
    ;------------------------------------------------------------
    ; Problem 6: If a compound procedure, we let it know its name
    ;------------------------------------------------------------
    (if (compound-procedure? val)
        (procedure-set-name! val var))
  )
)

; primitives procedures - hooks to underlying Scheme procs
(define (make-primitive-procedure implementation)
  (list 'primitive implementation))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define (primitive-procedures)
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'set-car! set-car!)
        (list 'set-cdr! set-cdr!)
        (list 'null? null?)
        (list '+ +)
        (list '- -)
        (list '< <)
        (list '> >)
        (list '= =)
        (list 'display display)
        (list 'not not)
        ;------------------------------------------------------------
        ; Problem 1: This is where we add to the primitive operations
        ;------------------------------------------------------------
        (list '* *)
        (list '/ /)
        (list 'list list)
        (list 'map map)
        (list 'cadr cadr)
        (list 'cddr cddr)
        (list 'newline newline)
        (list 'printf printf)
        (list 'length length)
        (list 'even? even?)
        ))

(define (primitive-procedure-names) (map car (primitive-procedures)))

(define (primitive-procedure-objects)
  (map make-primitive-procedure (map cadr (primitive-procedures))))

(define (apply-primitive-procedure proc args)
  (apply (primitive-implementation proc) args))

; used to initialize the environment
(define (setup-environment)
  (let ((initial-env (extend-environment (primitive-procedure-names)
                                         (primitive-procedure-objects)
                                         the-empty-environment #f))
        (oldwarn *meval-warn-define*))
    (set! *meval-warn-define* #f)
    (define-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    (set! *meval-warn-define* oldwarn)
    initial-env))

(define the-global-environment (setup-environment))

(define (refresh-global-environment)
  (set! the-global-environment (setup-environment))
  'done)

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 1: Our evaluator sucks
;------------------------------------------------------------
;------------------------------------------------------------

;------------------------------------------------------------
; Initially, our evaluator can't even do simple multiplication.
;------------------------------------------------------------
; M-Eval input: (+ 2 3) => M-Eval value: 5
; M-Eval input: (* 2 3) => . ;Unbound variable -- LOOKUP *
 
;------------------------------------------------------------
; After adding a few more primitives, we can now multiply.
; However, there still seems to be a slight problem with 'map'. 
;------------------------------------------------------------
; M-Eval input: (* 2 3) => M-Eval value: 6
; M-Eval input: (define test (list 1 2 3)) => M-Eval value: #<void>
; M-Eval input: (map (lambda (x) (* 2 x)) test)
;. ;map: expects type <procedure> as 1st argument, given: (procedure (x) ((* 2 x)) ((frame (test (1 2 3)) (false #f) (true #t) (car (primitive #<primitive:car>)) (cdr (primitive #<primitive:cdr>)) (cons (primitive #<primitive:cons>)) (set-car! (primitive #<primitive:set-car!>)) (set-cdr! (primitive #<pri...; other arguments were: (1 2 3)
 
;------------------------------------------------------------
;------------------------------------------------------------
; Problem 2: Undoing assignments
;
; Note 1: that the desired effect of 'reset!' on a parameter of 
; a lambda expression follows automatically from the following
; changes to the binding abstraction.
;
; Note 2: I did not know that the 'map' procedure is clever
; enough to be applied to multiple lists simultaneously! e.g.
; (map (lambda (x y) (+ x y)) (list 1 2 3) (list 2 3 4)) => (3 5 7)
;
;------------------------------------------------------------
; Example cases: 
;------------------------------------------------------------
; M-Eval input: (define x 5) => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 5
; M-Eval input: (set! x 10)  => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 10
; M-Eval input: (set! x 11)  => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 11
; M-Eval input: (set! x 12)  => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 12
; M-Eval input: (reset! x)   => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 5
; M-Eval input: (define x 15)=> M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 15
; M-Eval input: (set! x 16)  => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 16
; M-Eval input: (reset! x)   => M-Eval value: #<void>
; M-Eval input: x            => M-Eval value: 15
;------------------------------------------------------------
; M-Eval input: (reset! y)   =>. ;Reset: Binding not found
;------------------------------------------------------------
;------------------------------------------------------------

; special form
(define (reset? exp) (tagged-list? exp 'reset!))
(define (reset-binding exp) (cadr exp))
(define (eval-reset exp env)
  (let* ((binding-name (reset-binding exp))
         (binding      (find-in-environment binding-name env)))
    (if binding
        (reset-binding-value! binding)
        (error "Reset: Binding not found")
    )
  )
)
 
;------------------------------------------------------------
;------------------------------------------------------------
; Problem 3: before-advice
; Syntax: ``(before (procedure-name arguments ...) body ...)
;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
;M-Eval value:
; 6
;
;M-Eval input:
; (before (fact n) (printf "fact called on ~a ~n" n))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
; fact called on 3 
; fact called on 2 
; fact called on 1 
; fact called on 0 
;M-Eval value:
; 6
;
;M-Eval input:
; (reset! fact)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
;M-Eval value:
; 6
;------------------------------------------------------------
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (fact n) (printf "(1) I'm just counting down..."))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (fact n) (printf "(2) until I can see Spiderman 3!~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
; (1) I'm just counting down...(2) until I can see Spiderman 3!
; (1) I'm just counting down...(2) until I can see Spiderman 3!
; (1) I'm just counting down...(2) until I can see Spiderman 3!
; (1) I'm just counting down...(2) until I can see Spiderman 3!
;M-Eval value:
; 6
;------------------------------------------------------------
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (fact x y) (printf "Won't work!"))
; parameter-lists do not match
;------------------------------------------------------------
;;; M-Eval input:
;(before (does-not-exist lol) (printf "Huh?"))
;. ;eval-before: target procedure not found
;------------------------------------------------------------
;------------------------------------------------------------

;------------------------------------------------------------
; GENERIC 'ADVICE' DATA STRUCTURE that will house both 'before' 
; and 'around' advice types. The last parameter, `self-symbol'
; is useful for `around-advice' functionality later.
;------------------------------------------------------------
(define (make-advice type-tag parameters body env pointer self-symbol constraint)
  (list type-tag parameters body env pointer self-symbol constraint))

(define (advice-type advice)        (car    advice))
(define (advice-parameters advice)  (cadr   advice))
(define (advice-body advice)        (caddr  advice))
(define (advice-env advice)         (cadddr advice))
(define (advice-pointer advice)     (list-ref advice 4))
(define (advice-self-symbol advice) (list-ref advice 5))
(define (advice-constraint advice)  (list-ref advice 6))
(define (set-advice-pointer! advice new-pointer) (set-car! (cddddr advice) new-pointer))

;------------------------------------------------------------
; GENERIC INPUT SELECTORS, e.g.:
;   (advice-type (proc-name proc-args) body)
;------------------------------------------------------------
(define (advice-exp-proc exp) (cadr exp)) 
(define (advice-exp-body exp) (cddr exp))

;------------------------------------------------------------
; Problem 6: Selectors for optional constraints
;------------------------------------------------------------
(define (advice-exp-constraint exp)
  (let* ((proc (advice-exp-proc exp))
         (test (if (> (length proc) 1)  ;; the constraint is located syntactically
                   (cadr proc)          ;; in the second parameter location
                   #f)))
    (if (and test (tagged-list? test 'in))
        (cadr test)
        #f))
)

(define (advice-exp-name exp) 
  (car (advice-exp-proc exp)))
(define (advice-exp-args exp) 
  (let ((proc (advice-exp-proc exp)))
    (if (advice-exp-constraint exp) ;; The position of the argument list depends on whether
                                    ;; the optional constraint is invoked.
        (cddr proc)
        (cdr proc))))

;------------------------------------------------------------
; HELPER FUNCTIONS
;------------------------------------------------------------
(define (basic-procedure? proc)
  (or (primitive-procedure? proc)
      (compound-procedure? proc)))

(define (advice? advice)
  (or (before-advice? advice)
      (around-advice? advice)))

;; the following helps with the ordering of the advice.
(define (get-last-advice advice . stop)
  (let ((next     (advice-pointer advice))
        (stop-tag (if (null? stop) '() (car stop))))
    (if (or (basic-procedure? next)
            (eq? (advice-type next) stop-tag))
        advice
        (get-last-advice next))))

(define (get-underlying-proc advice)
  (advice-pointer (get-last-advice advice)))

;; this is the safe way to generically obtain the "bottom-most"
;; environment of an object
(define (get-underlying-environment object)
  (cond 
    ((primitive-procedure? object) the-global-environment)  ;; primitive procedures live in 
                                                            ;; the global environment
    ((compound-procedure?  object) (procedure-environment object))
    ((advice? object)
     (let ((underlying-proc (advice-pointer (get-last-advice object))))
       ;; For this application, when we want the underlying environment of an object
       ;; we are talking about the environment of its underlying-proc
       (get-environment underlying-proc)))
    (else (error "get-environment: I don't recognize the type of object"))
  )
)

(define (matching-parameter-list? proc param-list)
  (if (compound-procedure? proc)
      (= (length (procedure-parameters proc))
         (length param-list))
      #t ;; for primitive procedures, simply let the programmer have whatever
         ;; they want. (In other words, I don't know how to get a formal
         ;; parameter list for the primitives.)
  )
)
(define param-mismatch-error "parameter-lists do not match")

;------------------------------------------------------------
; A GENERIC EVALUATOR FOR ADVICE CREATION
;------------------------------------------------------------

;------------------------------------------------------------
; Problem 6:
; Modified evaluator for advice creation. Added the `constraint' 
; local variable which is passed to the make-advice procedure
;------------------------------------------------------------
(define (eval-advice exp env type . placement-option)
  (let* ((target-symbol    (advice-exp-name exp))
         (target-binding   (find-in-environment target-symbol env))
         (advice-param-lst (advice-exp-args exp))
         (advice-body      (advice-exp-body exp))
         (place-before     (if (null? placement-option) #f (car placement-option)))
         (constraint       (advice-exp-constraint exp))
        )
     (if (not target-binding)
         (error "eval-advice: target procedure not found")
         (let ((target-value (binding-value target-binding)))
           (cond ((or (basic-procedure? target-value)
                      (and place-before (advice? target-value)
                           (eq? place-before (advice-type target-value))))
                  ;; If the target satisfies the above criteria, the new object should
                  ;; go to the FRONT. i.e. we need to change the binding of the environment
                  ;; to this new object
                  (if (matching-parameter-list? target-value advice-param-lst)
                      (let ((advice-object (make-advice type 
                                                        advice-param-lst
                                                        advice-body
                                                        env
                                                        target-value
                                                        target-symbol
                                                        constraint)))
                      (set-variable-value! (binding-variable target-binding)
                                           advice-object
                                           (get-underlying-environment target-value)))
                      (error param-mismatch-error)))
                 ((advice? target-value)
                  ;; If the target is an advice, then we need to find the appropriate
                  ;; location for the advice as requested by the caller. Since the new object
                  ;; is going somewhere in the middle of the chain, we do not need to change
                  ;; any bindings in an environment.
                  (let* ((last-advice     (get-last-advice target-value 
                                                           (if place-before place-before)))
                         (underlying-proc (advice-pointer last-advice)))
                    (if (matching-parameter-list? underlying-proc advice-param-lst)
                        (let ((advice-object (make-advice type 
                                                          advice-param-lst
                                                          advice-body
                                                          env
                                                          underlying-proc
                                                          target-symbol
                                                          constraint)))
                          (set-advice-pointer! last-advice advice-object))
                        (error param-mismatch-error))))
                 ;; Not a procedure nor an advice => complain.
                 (else (error "eval-advice: target is neither procedure nor advice"))
            )
         )
     )
   )
)

;------------------------------------------------------------
; specific to `before-advice'
;------------------------------------------------------------
(define (before? exp)          (tagged-list? exp 'before))

;; representation as data
(define before-tag 'before-advice)
(define (before-advice? advice)
  (tagged-list? advice before-tag))

(define (eval-before exp env)
  (eval-advice exp env before-tag around-tag)) ;; the parameter 'around-tag' tells `eval-advice'
                                               ;; to place before-advice in front of around-advice

;; applying before-advice
(define (m-apply-before advice arguments env)
  (let ((constraint (advice-constraint advice)))
    (if constraint
        (run-before-constrained advice arguments constraint env)
        (run-before-advice advice arguments env)
    )
  )
)

(define (run-before-advice advice arguments env)
  (eval-sequence
   (advice-body advice)
   (extend-environment (advice-parameters advice)
                       arguments
                       (advice-env advice)
                       #f))
  (m-apply (advice-pointer advice) arguments env) ;; hook into the underlying procedure
)


(define (run-before-constrained advice arguments constraint env)
  (if (constraint-satisfied? constraint env)
      (run-before-advice advice arguments env)        ;; if the constraint is satisfied, then proceed as usual
      (m-apply (advice-pointer advice) arguments env) ;; if constraint is NOT satisfied, then
                                                      ;;  call the underlying procedure without
                                                      ;;  executing the before-advice body.
  )
)

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 4: around-advice
; Syntax: ``(around (procedure-name arguments ...) body ...)
;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
;M-Eval input:
; (define (square x) (* x x))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 25
;
;M-Eval input:
; (around (square x) (+ (square x) 1))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 26
;
;M-Eval input:
; (around (square x) (+ (square x) 1))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 27
;
;M-Eval input:
; (before (square x) (printf "square called on ~a ~n" x))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
; square called on 5     ;; Note that in my ordering of advice, all the 
                         ;; before-advice run prior to around-advice
;M-Eval value:
; 27
;
;M-Eval input:
; (reset! square)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 25
;
;------------------------------------------------------------
;
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (fact n) (if (< n 0) (* (fact (- n)) (if (even? n) 1 -1)) (fact n)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
;M-Eval value:
; 6
;
;M-Eval input:
; (fact -3)
;M-Eval value:
; -6
;
;------------------------------------------------------------
; THE FOLLOWING ILLUSTRATES WELL THE ORDER OF ADVICE-PLACEMENT
; FOLLOWED BY MY PROGRAM:
;
;M-Eval input:
; (define (foo) (printf "foo~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around1~n") (foo))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around2~n") (foo))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; around1
; around2
; foo
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (foo) (printf "before1~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; before1
; around1
; around2
; foo
;M-Eval value:
; #<void>
;------------------------------------------------------------
; Note further that I attach newer advice at the end. Given 
; that 'around-advice' executes the underlying object only 
; if an explicit call is made within its body, it is possible
; that the newly-attached advices may not show up, as in the 
; following case:
;
;M-Eval input:
; (define (foo) (printf "foo~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around1~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around2~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; around1
;M-Eval value:
; #<void>
;
; Note that the second around-advice does NOT show up. This is the expected
; behavior. What's happening is that the second around-advice IS in fact 
; being pointed to by the first around-advice. However, since the first around-
; advice does not call 'foo' within its body, the underlying objects, including
; additional advices are not called.
;------------------------------------------------------------
;------------------------------------------------------------

;(define (around? exp) (tagged-list? exp 'around))

(define around-tag 'around-advice)
(define (around-advice? around)
  (tagged-list? around around-tag))

(define (eval-around exp env)
  (eval-advice exp env around-tag))

;------------------------------------------------------------
; applying around-advice
;------------------------------------------------------------
; Note that `run-around-advice' does not need the 'env' parameter
;   because it does not make a recursive call to m-apply as
;   before-advice did.
;------------------------------------------------------------
(define (m-apply-around advice arguments env)
  (let ((constraint (advice-constraint advice)))
    (if constraint
        (run-around-constrained advice arguments constraint env)
        (run-around-advice advice arguments)
    )
  )
)

(define (run-around-advice advice arguments)
  (eval-sequence
   (advice-body advice)
   ;; We bind the original symbol to the underlying object
   ;; of our around-advice (its pointee)
   (extend-environment (append (advice-parameters advice)
                               (list (advice-self-symbol advice)))
                       (append arguments
                               (list (advice-pointer advice)))
                       (advice-env advice)
                       #f))
)

(define (run-around-constrained advice arguments constraint env)
  (if (constraint-satisfied? constraint env)
      (run-around-advice advice arguments)            ;; if the constraint is satisfied, then proceed as usual
      (m-apply (advice-pointer advice) arguments env) ;; if constraint is NOT satisfied, then
                                                      ;;  call the underlying procedure without
                                                      ;;  executing the before-advice body.
  )
)

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 5: after-advice
; Syntax: ``(after (procedure-name arguments ... result) body ...)
;
; The strategy is to desugar the above into an 'around-advice'
; with the following body:
;
; (let ((result (procedure-name arguments)))
;   body)
;
; Unfortunately since the after-advice is desugared into 
; an around-advice, rather than existing as a separate object,
; we can not use the previous techniques to order between around 
; and after-advices. So the only promise that I give is that
; before-advice are ran prior to around- and after-advices
; which may run in arbitrary order.
;
;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
; (define test '(after (fact n result) (printf "lol") (printf "lol-again!")))
;
; test => (after (fact n result) (printf "lol") (printf "lol-again!"))
;
; (after->around-let test) => 
;    (around (fact n) (let ((result (fact n))) (printf "lol") (printf "lol-again!") result))
;------------------------------------------------------------
; (define test2 '(after (dummy result) (printf "dummy!")))
;
; test2 => (after (dummy result) (printf "dummy!"))
;
; (after->around-let test2) =>
;     (around (dummy) (let ((result (dummy))) (printf "dummy!") result))
;------------------------------------------------------------
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (after (fact n result) (printf "fact returned ~a ~n" result))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
; fact returned 1 
; fact returned 1 
; fact returned 2 
; fact returned 6 
;M-Eval value:
; 6
;
;M-Eval input:
; (before (fact n) (printf "fact called~n"))
;M-Eval value:
; #<void>
;
; The ordering of the following outputs is very sensible given
; what we know about recursion and deferred operations (which this
; implementation of `fact' follows.)
;
;M-Eval input:
; (fact 3)
; fact called
; fact called
; fact called
; fact called
; fact returned 1 
; fact returned 1 
; fact returned 2 
; fact returned 6 
;M-Eval value:
; 6
;------------------------------------------------------------
;------------------------------------------------------------

(define (after? exp) (tagged-list? exp 'after))

;; helper for cdr'ing a list
(define (do-n-cdrs lst n)
  (if (<= n 0)
      lst
      (do-n-cdrs (cdr lst) (- n 1))))

(define test '(after (eval n result) (printf "done!")))

(define (after->around-let exp)
  (let* ((proc-arg-list   (advice-exp-args exp))
         (last-index      (- (length proc-arg-list) 1))
         (result-variable (list-ref proc-arg-list last-index)))
    ;; Remove the result variable from the argument list; i.e.
    ;; `set-cdr!' the pair before the last element to null
    (set-cdr! (do-n-cdrs proc-arg-list (- last-index 1)) '())
    (list 'around 
          (advice-exp-proc exp) ;; recall that the procedure was mutated in place
          (make-let (list (list result-variable
                                (append (list (advice-exp-name exp))
                                        proc-arg-list)))
                    (append (advice-exp-body exp)
                            (list result-variable)) ;; I pass down the result because some
                                                    ;; recursive functions, such as `fact' may
                                                    ;; require the previous result to proceed.
          )
    )
  )
)
        

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 6: constraints
;------------------------------------------------------------
; I have re-defined the pertinent procedures in place. Please
; look at the section for problem 3, at the underlying
; generic procedures.
;------------------------------------------------------------
; Some sample cases:
;------------------------------------------------------------
; (define test  '(before (+ x y) (set! count (+ count 1))))
; (define test2 '(before (+ (in fib) x y) (set! count (+ count 1))))
; test  => (before (+ x y) (set! count (+ count 1)))
; test2 => (before (+ (in fib) x y) (set! count (+ count 1)))
; (advice-exp-constraint? test)  => #f
; (advice-exp-constraint? test2) => fib
; (advice-exp-args test)  => (x y)
; (advice-exp-args test2) => (x y)
;
; More examples, demonstrating constraints as well as the other
; functionality of the project are described at the end of this
; document.
;
;------------------------------------------------------------
;------------------------------------------------------------

;------------------------------------------------------------
; Change the behavior of m-apply
;------------------------------------------------------------
; Now we need a way to check whether we are in the scope of a 
; particular function. I will implement the suggested method of 
; modifying the frame object so that it records the creator.
;
; This in turn requires that we need to be able to access the 
; symbol of a procedure to be applied. This is a tricky issue
; because within `m-apply' we are working with the procedure
; data OBJECT, rather than the binding. We do not have a method
; to retrieve the corresponding symbol from the object. Hence, we need to 
; expand the internal representation of a procedure, so that it knows what
; its name is. (I did consider alternate methods. However, although
; they may be simpler to implement, they introduce a major 
; conceptual change to the evaluator (i.e. procedures are not 
; evaluated before being passed to `apply') and break existing
; code.)
;
; This in turn is another tricky issue. The complication is that
; objects acquire a (symbolic) name NOT when they are created, but
; when they are NAMED. So, consider for example:
;
; (lambda () (printf "bar~n"))
;
; The returned "double-bubble" object of the above expression does 
; NOT yet have a name. But consider:
;
; (define bar (lambda () (printf "bar~n")))
;
; In this case, the procedure object DOES have a name, and it is
; 'bar'. THE CONCLUSION OF THIS DISCUSSION IS THAT IT IS THE DEFINE
; SPECIAL FORM THAT GIVES OBJECTS SYMBOLIC NAMES. This is a rather
; simple point in retrospect, but is CRUCIAL for my implementation.
;
; So! We need to change the `define' such that if applied to a 
; procedure it needs to let it know its name. Please see the
; changes to 'define-variable!' Other pertinent changes can be 
; found in the definitions of:
;
;    `make-procedure'
;    `extend-environment'
;    `make-frame' (and related selectors)
;
;------------------------------------------------------------

;------------------------------------------------------------
; constraint checks
;------------------------------------------------------------

;------------------------------------------------------------
; 'get-env-creators' takes an environment (list of frames) 
; and returns the creators of each frame, e.g.
;------------------------------------------------------------
; (define test-environment 
;   (extend-environment '(x y) '(3 4) the-global-environment 'the-environment-god))
; (get-env-creators test-environment) => (the-environment-god #f)
;------------------------------------------------------------
(define (get-env-creators env)
  (map frame-creator env))

;------------------------------------------------------------
; 'constraint-satisfied?' is pretty self-explanatory. Usage:
;------------------------------------------------------------
; (define test-environment 
;   (extend-environment '(x y) '(3 4) the-global-environment 'the-environment-god))
;
; (get-env-creators test-environment) 
;   => (the-environment-god #f)
;
; (constraint-satisfied? 'the-environment-god test-environment)
;   => (the-environment-god #f)
;
; (constraint-satisfied? 'the-environment-goddess test-environment)
;   => #f
;------------------------------------------------------------
(define (constraint-satisfied? constraint env)
  (memq constraint (get-env-creators env)))

;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
;M-Eval input:
; (define (f)
;  (define (g) (+ 2 3))
;  (+ (g) (h)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define (h) (+ 5 6))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (before (+ (in f) x y) (printf "~a + ~a ~n" x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; 2 + 3 
; 5 + 11 
;M-Eval value:
; 16
;
;M-Eval input:
; (h)
;M-Eval value:
; 11
;
;M-Eval input:
; (reset! +)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (before (+ x y) (printf "~a + ~a ~n" x y)) 
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; 2 + 3 
; 5 + 6 
; 5 + 11 
;M-Eval value:
; 16
;------------------------------------------------------------
;M-Eval input:
; (define (fib n)
;  (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define count 0)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (+ (in fib) x y) (set! count (+ count 1)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fib 5)
;M-Eval value:
; 5
;
;M-Eval input:
; count
;M-Eval value:
; 7
;
; We can check this number for: (fib 5)
;
; -> (+ (fib 4) (fib 3))
; -> (+ (+ (fib 3) (fib 2)) 
;       (+ (fib 2) (fib 1)))
; -> (+ (+ (+ (fib 2) (fib 1))
;          (+ (fib 1) (fib 0)))
;       (+ (+ (fib 1) (fib 0))
;          (fib 1)))
; -> (+ (+ (+ (+ (fib 1) (fib 0)) (fib 1))
;          (+ (fib 1) (fib 0)))
;       (+ (+ (fib 1) (fib 0))
;          (fib 1)))
;
; Since the remaining calls to fib simply returns the parameter,
; a count of 7 additions appears to be correct for (fib 5).
;
;------------------------------------------------------------
;M-Eval input:
; (define (i-cant-multiply x y) (* x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (i-cant-multiply 2 5)
;M-Eval value:
; 10
;
;M-Eval input:
; (around (* (in i-cant-multiply) x y) (printf "i can't multiply!~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (i-cant-multiply 2 5)
; i can't multiply!
;M-Eval value:
; #<void>
;
;M-Eval input:
; (* 2 5)
;M-Eval value:
; 10
;------------------------------------------------------------
;M-Eval input:
; (define (f)
; (define (g) (+ 2 3))
;  (+ (g) (h)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define (h) (+ 5 6))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (around (+ (in g) x y) (printf "In (g) we call multiplication to be '+'~n") (* x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; In (g) we call multiplication to be '+'
;M-Eval value:
; 17
;
;M-Eval input:
; (before (h (in f)) (printf "h was called from f~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; In (g) we call multiplication to be '+'
; h was called from f
;M-Eval value:
; 17
;
;M-Eval input:
; (h)
;M-Eval value:
; 11
;------------------------------------------------------------
;------------------------------------------------------------
;M-Eval input:
; (around (square x) (+ (square x) 1))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 27
;
;M-Eval input:
; (before (square x) (printf "square called on ~a ~n" x))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
; square called on 5     ;; Note that in my ordering of advice, all the 
                         ;; before-advice run prior to around-advice
;M-Eval value:
; 27
;
;M-Eval input:
; (reset! square)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (square 5)
;M-Eval value:
; 25
;
;------------------------------------------------------------
;
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (fact n) (if (< n 0) (* (fact (- n)) (if (even? n) 1 -1)) (fact n)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
;M-Eval value:
; 6
;
;M-Eval input:
; (fact -3)
;M-Eval value:
; -6
;
;------------------------------------------------------------
; THE FOLLOWING ILLUSTRATES WELL THE ORDER OF ADVICE-PLACEMENT
; FOLLOWED BY MY PROGRAM:
;
;M-Eval input:
; (define (foo) (printf "foo~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around1~n") (foo))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around2~n") (foo))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; around1
; around2
; foo
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (foo) (printf "before1~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; before1
; around1
; around2
; foo
;M-Eval value:
; #<void>
;------------------------------------------------------------
; Note further that I attach newer advice at the end. Given 
; that 'around-advice' executes the underlying object only 
; if an explicit call is made within its body, it is possible
; that the newly-attached advices may not show up, as in the 
; following case:
;
;M-Eval input:
; (define (foo) (printf "foo~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around1~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (around (foo) (printf "around2~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (foo)
; around1
;M-Eval value:
; #<void>
;
; Note that the second around-advice does NOT show up. This is the expected
; behavior. What's happening is that the second around-advice IS in fact 
; being pointed to by the first around-advice. However, since the first around-
; advice does not call 'foo' within its body, the underlying objects, including
; additional advices are not called.
;------------------------------------------------------------
;------------------------------------------------------------

(define (around? exp) (tagged-list? exp 'around))

;(define around-tag 'around-advice)
;(define (around-advice? around)
;  (tagged-list? around around-tag))

;(define (eval-around exp env)
;  (eval-advice exp env around-tag))

;------------------------------------------------------------
; applying around-advice
;------------------------------------------------------------
; Note that `run-around-advice' does not need the 'env' parameter
;   because it does not make a recursive call to m-apply as
;   before-advice did.
;------------------------------------------------------------
;(define (m-apply-around advice arguments env)
;  (let ((constraint (advice-constraint advice)))
;    (if constraint
;        (run-around-constrained advice arguments constraint env)
;        (run-around-advice advice arguments)
;    )
;  )
;)

;(define (run-around-advice advice arguments)
;  (eval-sequence
;   (advice-body advice)
   ;; We bind the original symbol to the underlying object
   ;; of our around-advice (its pointee)
;   (extend-environment (append (advice-parameters advice)
;                               (list (advice-self-symbol advice)))
;                       (append arguments
;                               (list (advice-pointer advice)))
;                       (advice-env advice)
;                       #f))
;)

;(define (run-around-constrained advice arguments constraint env)
;  (if (constraint-satisfied? constraint env)
;      (run-around-advice advice arguments)            ;; if the constraint is satisfied, then proceed as usual
;      (m-apply (advice-pointer advice) arguments env) ;; if constraint is NOT satisfied, then
;                                                      ;;  call the underlying procedure without
;                                                      ;;  executing the before-advice body.
;  )
;)

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 5: after-advice
; Syntax: ``(after (procedure-name arguments ... result) body ...)
;
; The strategy is to desugar the above into an 'around-advice'
; with the following body:
;
; (let ((result (procedure-name arguments)))
;   body)
;
; Unfortunately since the after-advice is desugared into 
; an around-advice, rather than existing as a separate object,
; we can not use the previous techniques to order between around 
; and after-advices. So the only promise that I give is that
; before-advice are ran prior to around- and after-advices
; which may run in arbitrary order.
;
;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
; (define test '(after (fact n result) (printf "lol") (printf "lol-again!")))
;
; test => (after (fact n result) (printf "lol") (printf "lol-again!"))
;
; (after->around-let test) => 
;    (around (fact n) (let ((result (fact n))) (printf "lol") (printf "lol-again!") result))
;------------------------------------------------------------
; (define test2 '(after (dummy result) (printf "dummy!")))
;
; test2 => (after (dummy result) (printf "dummy!"))
;
; (after->around-let test2) =>
;     (around (dummy) (let ((result (dummy))) (printf "dummy!") result))
;------------------------------------------------------------
;M-Eval input:
; (define (fact n) (if (= n 0) 1 (* n (fact (- n 1)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (after (fact n result) (printf "fact returned ~a ~n" result))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fact 3)
; fact returned 1 
; fact returned 1 
; fact returned 2 
; fact returned 6 
;M-Eval value:
; 6
;
;M-Eval input:
; (before (fact n) (printf "fact called~n"))
;M-Eval value:
; #<void>
;
; The ordering of the following outputs is very sensible given
; what we know about recursion and deferred operations (which this
; implementation of `fact' follows.)
;
;M-Eval input:
; (fact 3)
; fact called
; fact called
; fact called
; fact called
; fact returned 1 
; fact returned 1 
; fact returned 2 
; fact returned 6 
;M-Eval value:
; 6
;------------------------------------------------------------
;------------------------------------------------------------

;(define (after? exp) (tagged-list? exp 'after))

;; helper for cdr'ing a list
;(define (do-n-cdrs lst n)
;  (if (<= n 0)
;      lst
;      (do-n-cdrs (cdr lst) (- n 1))))

;(define test '(after (eval n result) (printf "done!")))

;(define (after->around-let exp)
;  (let* ((proc-arg-list   (advice-exp-args exp))
;         (last-index      (- (length proc-arg-list) 1))
;         (result-variable (list-ref proc-arg-list last-index)))
    ;; Remove the result variable from the argument list; i.e.
    ;; `set-cdr!' the pair before the last element to null
;    (set-cdr! (do-n-cdrs proc-arg-list (- last-index 1)) '())
;    (list 'around 
;          (advice-exp-proc exp) ;; recall that the procedure was mutated in place
;          (make-let (list (list result-variable
;                                (append (list (advice-exp-name exp))
;                                        proc-arg-list)))
;                    (append (advice-exp-body exp)
;                            (list result-variable)) ;; I pass down the result because some
;                                                    ;; recursive functions, such as `fact' may
;                                                    ;; require the previous result to proceed.
;          )
;    )
;  )
;)
        

;------------------------------------------------------------
;------------------------------------------------------------
; Problem 6: constraints
;------------------------------------------------------------
; I have re-defined the pertinent procedures in place. Please
; look at the section for problem 3, at the underlying
; generic procedures.
;------------------------------------------------------------
; Some sample cases:
;------------------------------------------------------------
; (define test  '(before (+ x y) (set! count (+ count 1))))
; (define test2 '(before (+ (in fib) x y) (set! count (+ count 1))))
; test  => (before (+ x y) (set! count (+ count 1)))
; test2 => (before (+ (in fib) x y) (set! count (+ count 1)))
; (advice-exp-constraint? test)  => #f
; (advice-exp-constraint? test2) => fib
; (advice-exp-args test)  => (x y)
; (advice-exp-args test2) => (x y)
;
; More examples, demonstrating constraints as well as the other
; functionality of the project are described at the end of this
; document.
;
;------------------------------------------------------------
;------------------------------------------------------------

;------------------------------------------------------------
; Change the behavior of m-apply
;------------------------------------------------------------
; Now we need a way to check whether we are in the scope of a 
; particular function. I will implement the suggested method of 
; modifying the frame object so that it records the creator.
;
; This in turn requires that we need to be able to access the 
; symbol of a procedure to be applied. This is a tricky issue
; because within `m-apply' we are working with the procedure
; data OBJECT, rather than the binding. We do not have a method
; to retrieve the corresponding symbol from the object. Hence, we need to 
; expand the internal representation of a procedure, so that it knows what
; its name is. (I did consider alternate methods. However, although
; they may be simpler to implement, they introduce a major 
; conceptual change to the evaluator (i.e. procedures are not 
; evaluated before being passed to `apply') and break existing
; code.)
;
; This in turn is another tricky issue. The complication is that
; objects acquire a (symbolic) name NOT when they are created, but
; when they are NAMED. So, consider for example:
;
; (lambda () (printf "bar~n"))
;
; The returned "double-bubble" object of the above expression does 
; NOT yet have a name. But consider:
;
; (define bar (lambda () (printf "bar~n")))
;
; In this case, the procedure object DOES have a name, and it is
; 'bar'. THE CONCLUSION OF THIS DISCUSSION IS THAT IT IS THE DEFINE
; SPECIAL FORM THAT GIVES OBJECTS SYMBOLIC NAMES. This is a rather
; simple point in retrospect, but is CRUCIAL for my implementation.
;
; So! We need to change the `define' such that if applied to a 
; procedure it needs to let it know its name. Please see the
; changes to 'define-variable!' Other pertinent changes can be 
; found in the definitions of:
;
;    `make-procedure'
;    `extend-environment'
;    `make-frame' (and related selectors)
;
;------------------------------------------------------------

;------------------------------------------------------------
; constraint checks
;------------------------------------------------------------

;------------------------------------------------------------
; 'get-env-creators' takes an environment (list of frames) 
; and returns the creators of each frame, e.g.
;------------------------------------------------------------
; (define test-environment 
;   (extend-environment '(x y) '(3 4) the-global-environment 'the-environment-god))
; (get-env-creators test-environment) => (the-environment-god #f)
;------------------------------------------------------------
;(define (get-env-creators env)
;  (map frame-creator env))

;------------------------------------------------------------
; 'constraint-satisfied?' is pretty self-explanatory. Usage:
;------------------------------------------------------------
; (define test-environment 
;   (extend-environment '(x y) '(3 4) the-global-environment 'the-environment-god))
;
; (get-env-creators test-environment) 
;   => (the-environment-god #f)
;
; (constraint-satisfied? 'the-environment-god test-environment)
;   => (the-environment-god #f)
;
; (constraint-satisfied? 'the-environment-goddess test-environment)
;   => #f
;------------------------------------------------------------
;(define (constraint-satisfied? constraint env)
;  (memq constraint (get-env-creators env)))

;------------------------------------------------------------
; Example cases:
;------------------------------------------------------------
;M-Eval input:
; (define (f)
;  (define (g) (+ 2 3))
;  (+ (g) (h)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define (h) (+ 5 6))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (before (+ (in f) x y) (printf "~a + ~a ~n" x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; 2 + 3 
; 5 + 11 
;M-Eval value:
; 16
;
;M-Eval input:
; (h)
;M-Eval value:
; 11
;
;M-Eval input:
; (reset! +)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (before (+ x y) (printf "~a + ~a ~n" x y)) 
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; 2 + 3 
; 5 + 6 
; 5 + 11 
;M-Eval value:
; 16
;------------------------------------------------------------
;M-Eval input:
; (define (fib n)
;  (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define count 0)
;M-Eval value:
; #<void>
;
;M-Eval input:
; (before (+ (in fib) x y) (set! count (+ count 1)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (fib 5)
;M-Eval value:
; 5
;
;M-Eval input:
; count
;M-Eval value:
; 7
;
; We can check this number for: (fib 5)
;
; -> (+ (fib 4) (fib 3))
; -> (+ (+ (fib 3) (fib 2)) 
;       (+ (fib 2) (fib 1)))
; -> (+ (+ (+ (fib 2) (fib 1))
;          (+ (fib 1) (fib 0)))
;       (+ (+ (fib 1) (fib 0))
;          (fib 1)))
; -> (+ (+ (+ (+ (fib 1) (fib 0)) (fib 1))
;          (+ (fib 1) (fib 0)))
;       (+ (+ (fib 1) (fib 0))
;          (fib 1)))
;
; Since the remaining calls to fib simply returns the parameter,
; a count of 7 additions appears to be correct for (fib 5).
;
;------------------------------------------------------------
;M-Eval input:
; (define (i-cant-multiply x y) (* x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (i-cant-multiply 2 5)
;M-Eval value:
; 10
;
;M-Eval input:
; (around (* (in i-cant-multiply) x y) (printf "i can't multiply!~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (i-cant-multiply 2 5)
; i can't multiply!
;M-Eval value:
; #<void>
;
;M-Eval input:
; (* 2 5)
;M-Eval value:
; 10
;------------------------------------------------------------
;M-Eval input:
; (define (f)
; (define (g) (+ 2 3))
;  (+ (g) (h)))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (define (h) (+ 5 6))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
;M-Eval value:
; 16
;
;M-Eval input:
; (around (+ (in g) x y) (printf "In (g) we call multiplication to be '+'~n") (* x y))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; In (g) we call multiplication to be '+'
;M-Eval value:
; 17
;
;M-Eval input:
; (before (h (in f)) (printf "h was called from f~n"))
;M-Eval value:
; #<void>
;
;M-Eval input:
; (f)
; In (g) we call multiplication to be '+'
; h was called from f
;M-Eval value:
; 17
;
;M-Eval input:
; (h)
;M-Eval value:
; 11
;------------------------------------------------------------
;------------------------------------------------------------